home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / tools / setup.lisp < prev    next >
Lisp/Scheme  |  1992-05-19  |  6KB  |  206 lines
  1. ;;; -*- Package: USER -*-
  2. ;;;
  3. ;;;    Set up package environment and search lists for compiler.  Also some
  4. ;;; compilation utilities.
  5. ;;;
  6. (in-package "USER")
  7.  
  8.  
  9. ;;; DUMP-PACKAGE-STATE  --  Public
  10. ;;;
  11. (defun dump-package-state (packages file)
  12.   (declare (type (or list package symbol string) packages)
  13.        (type (or pathname symbol string) file))
  14.   (let* ((packages (lisp::package-listify packages)))
  15.     (collect ((forms))
  16.       (dolist (pkg packages)
  17.     (let ((nicks (package-nicknames pkg))
  18.           (name (package-name pkg))
  19.           (shad (package-shadowing-symbols pkg)))
  20.       (forms `(if (find-package ,name)
  21.               (rename-package ,name ,name ',nicks)
  22.               (make-package ,name :nicknames ',nicks :use nil)))
  23.       (when shad
  24.         (forms `(shadow ',(mapcar #'string shad) ,name)))))
  25.  
  26.       (dolist (pkg packages)
  27.     (forms `(use-package ',(mapcar #'package-name
  28.                        (package-use-list pkg))
  29.                  ,(package-name pkg))))
  30.  
  31.       (dolist (old packages)
  32.     (collect ((exports))
  33.       (let ((imports (make-hash-table :test #'eq)))
  34.         (do-symbols (sym old)
  35.           (let ((pkg (symbol-package sym))
  36.             (name (symbol-name sym)))
  37.         (multiple-value-bind (found how)
  38.                      (find-symbol name old)
  39.           (assert (and (eq found sym) how))
  40.           (cond
  41.            ((not pkg)
  42.             (warn "Not dumping uninterned symbol ~S." sym))
  43.            ((eq how :inherited))
  44.            (t
  45.             (unless (eq pkg old)
  46.               (pushnew name (gethash pkg imports) :test #'string=))
  47.             (when (eq how :external)
  48.               (exports name)))))))
  49.         (collect ((import-froms))
  50.           (maphash #'(lambda (pkg raw-names)
  51.                (let ((names (sort (delete-duplicates raw-names
  52.                                  :test
  53.                                  #'string=)
  54.                           #'string<))
  55.                  (pkg-name (package-name pkg)))
  56.                  (when names
  57.                    (import-froms `(:import-from ,pkg-name ,@names))
  58.                    (dolist (name names)
  59.                  (forms `(intern ,name ,pkg-name))))))
  60.                imports)
  61.           (forms `(defpackage ,(package-name old)
  62.             ,@(import-froms)
  63.             ,@(when (exports)
  64.                 `((:export
  65.                    ,@(sort (delete-duplicates (exports)
  66.                               :test #'string=)
  67.                        #'string<))))))))))
  68.  
  69.       (with-open-file (s file :direction :output :if-exists :new-version)
  70.     (dolist (form (forms))
  71.       (write form :stream s :pretty t)
  72.       (terpri s)))))
  73.  
  74.   (values))
  75.   
  76.  
  77. ;;; COPY-PACKAGES  --  Public
  78. ;;;
  79. (defun copy-packages (packages)
  80.   "Rename all the of the Named packages to OLD-Name, and then create new
  81.   packages for each name that have the same names, nicknames, imports, shadows
  82.   and exports.  If any of the OLD-Name packages already exist, then we quietly
  83.   do nothing."
  84.   (let* ((packages (lisp::package-listify packages))
  85.      (names (mapcar #'package-name packages))
  86.      (new-names (mapcar #'(lambda (x)
  87.                 (concatenate 'string "OLD-" x))
  88.                 names)))
  89.     (unless (some #'find-package new-names)
  90.       (collect ((new-packages))
  91.     (flet ((trans-pkg (x)
  92.          (or (cdr (assoc x (new-packages))) x)))
  93.       (loop for pkg in packages and new in new-names do
  94.         (let ((nicks (package-nicknames pkg))
  95.           (name (package-name pkg)))
  96.           (rename-package pkg new)
  97.           (let ((new-pkg (make-package name :nicknames nicks :use nil))
  98.             (shad (package-shadowing-symbols pkg)))
  99.         (when shad
  100.           (shadow shad new-pkg))
  101.         (new-packages (cons pkg new-pkg)))))
  102.       
  103.       (loop for (old . new) in (new-packages) do
  104.         (dolist (use (package-use-list old))
  105.           (use-package (trans-pkg use) new)))
  106.       
  107.       (loop for (old . new) in (new-packages) do
  108.         (do-symbols (sym old)
  109.           (let ((pkg (symbol-package sym))
  110.             (name (symbol-name sym)))
  111.         (multiple-value-bind (found how)
  112.                      (find-symbol name old)
  113.           (assert (and (eq found sym) how))
  114.           (cond
  115.            ((not pkg)
  116.             (warn "Not copying uninterned symbol ~S." sym))
  117.            ((or (eq how :inherited)
  118.             (and (eq how :internal) (eq pkg old))))
  119.            (t
  120.             (let* ((npkg (trans-pkg pkg))
  121.                (nsym (intern name npkg)))
  122.               (multiple-value-bind (ignore new-how)
  123.                        (find-symbol name new)
  124.             (declare (ignore ignore))
  125.             (unless new-how (import nsym new)))
  126.               (when (eq how :external)
  127.             (export nsym new)))))))))))))
  128.   (values))
  129.  
  130.  
  131. ;;;; Compile utility:
  132.  
  133. ;;; Switches:
  134. ;;;
  135. (defvar *interactive* t) ; Batch compilation mode?
  136.  
  137. (defvar *log-file* nil)
  138. (defvar *last-file-position*)
  139.  
  140. (defmacro with-compiler-log-file ((name &rest wcu-keys) &body forms)
  141.   `(if *interactive*
  142.        (with-compilation-unit (,@wcu-keys)
  143.      ,@forms)
  144.        (let ((*log-file* (open ,name :direction :output
  145.                    :if-exists :append
  146.                    :if-does-not-exist :create)))
  147.      (unwind-protect
  148.          (let ((*error-output* *log-file*)
  149.            (*last-file-position* (file-position *log-file*)))
  150.            (with-compilation-unit (,@wcu-keys)
  151.          ,@forms))
  152.        (close *log-file*)))))
  153.  
  154.  
  155. (defun comf (name &key always-once proceed load output-file assem)
  156.   (declare (ignore always-once))
  157.   (when (and *log-file*
  158.          (> (- (file-position *log-file*) *last-file-position*) 10000))
  159.     (setq *last-file-position* (file-position *log-file*))
  160.     (force-output *log-file*))
  161.  
  162.   (let* ((src (pathname (concatenate 'string name ".lisp")))
  163.      (obj (if output-file
  164.           (pathname output-file)
  165.           (make-pathname :defaults src
  166.                  :type
  167.                  (if assem
  168.                      "assem"
  169.                      (c:backend-fasl-file-type c:*backend*))))))
  170.  
  171.     (unless (and (probe-file obj)
  172.          (>= (file-write-date obj) (file-write-date src)))
  173.       (write-line name)
  174.       (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
  175.           (ext:format-universal-time nil (get-universal-time))
  176.           name)
  177.       (catch 'blow-this-file
  178.     (cond
  179.      (*interactive*
  180.       (if assem
  181.           (c::assemble-file src :output-file obj)
  182.           (compile-file src  :error-file nil  :output-file obj))
  183.       (when load
  184.         (load name :verbose t)))
  185.      (t
  186.       (handler-bind ((error #'(lambda (condition)
  187.                     (format *error-output* "~2&~A~2&"
  188.                         condition)
  189.                     (when proceed
  190.                       (format *error-output* "Proceeding...~%")
  191.                       (continue))
  192.                     (format *error-output* "Aborting...~%")
  193.                     (handler-case
  194.                     (let ((*debug-io* *error-output*))
  195.                       (debug:backtrace))
  196.                       (error (condition)
  197.                     (declare (ignore condition))
  198.                     (format t "Error in backtrace!~%")))
  199.                     (format t "Error abort.~%")
  200.                     (return-from comf))))
  201.         (if assem
  202.         (c::assemble-file src :output-file obj)
  203.         (compile-file src  :error-file nil  :output-file obj))
  204.         (when load
  205.           (load name :verbose t)))))))))
  206.